home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / misc / system-builder.lisp < prev   
Lisp/Scheme  |  1992-09-10  |  9KB  |  296 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; Wimpy system building tool. Not Fancy and mildly useful.
  4.  
  5. (in-package "SYSTEM-BUILDER"
  6.         :nicknames '("SB")
  7.         :use '("LISP" #+LUCID "LUCID-COMMON-LISP"))
  8.  
  9. ;;; Desired improvements :
  10. ;;;   compile and load source
  11. ;;;   save-system
  12. ;;;   :recompile-all
  13. ;;;   :load-only
  14. ;;;   :bin-directory
  15.  
  16. (export '(define-system
  17.           build-system
  18.       system-files
  19.       count-system-lines
  20.       count-system-characters
  21.           edit-system
  22.           print-system))
  23.  
  24. (defvar *verbose-build* nil "True for verbosity")
  25. (defvar *system-builder-compiler*)
  26. (defvar *skip-load?*)
  27. (defvar *force-update?*)
  28.  
  29. (defstruct system-info
  30.   name
  31.   package
  32.   files
  33.   directory
  34.   source-extension
  35.   binary-extension
  36.   load-date-table)
  37.  
  38. (defvar *info*
  39.   nil
  40.   "Current SYSTEM-INFO structure for system being worked on")
  41.  
  42. (defvar *known-systems*
  43.   (make-hash-table)
  44.   "Information about all systems defined with DEFINE-SYSTEM")
  45.  
  46. (defmacro sys-dependent-defer-warnings (&rest forms)
  47.   #+lucid `(with-deferred-warnings ,@forms)
  48.   #+cmu `(with-compilation-unit () ,@forms)
  49.   #-lucid `(progn ,@forms))
  50.  
  51. (defmacro define-system (name &rest options)
  52.   `(define-system-internal ',name ,@options))
  53.  
  54. (defun find-system (name)
  55.   (gethash name *known-systems*))
  56.  
  57. (defun define-system-internal (name &key
  58.                     (package name)
  59.                     files
  60.                     directory
  61.                     source-extension
  62.                     binary-extension)
  63.   (labels ((update-system-info (info)
  64.          (setf (system-info-name info) name)
  65.          (setf (system-info-package info) package)
  66.              (setf (system-info-files info) files)
  67.          (setf (system-info-directory info) directory)
  68.          (setf (system-info-source-extension info)
  69.            source-extension)
  70.          (setf (system-info-binary-extension info)
  71.            binary-extension)
  72.              (when (null (system-info-load-date-table info))
  73.            (setf (system-info-load-date-table info)
  74.              (make-hash-table :test #'equal)))))
  75.     (let ((info (gethash name *known-systems*)))
  76.       (if (null info)
  77.       (let ((new-info (make-system-info :name name)))
  78.         (update-system-info new-info)
  79.         (setf (gethash name *known-systems*) new-info))
  80.       (update-system-info info))
  81.       name)))
  82.  
  83. ;;; BUILD means compile-load "as needed".
  84. ;;; Lots of stuff hidden in "as needed."
  85. (defun perform-system-action (name action-function)
  86.   (let ((*info* (find-system name)))
  87.     (if (null *info*)
  88.     (error "No information found for system ~A." name)
  89.     (let ((*package* (find-package (system-info-package *info*))))
  90.       (funcall action-function)))))
  91.  
  92. (defun build-system (name &key ((:compile-file *system-builder-compiler*)
  93.                 #'compile-file)
  94.               ((:skip-load? *skip-load?*) nil)
  95.               ((:force-update? *force-update?*) nil))
  96.   (sys-dependent-defer-warnings
  97.    (perform-system-action name #'build-system-internal)))
  98.  
  99. (defun system-files (name)
  100.   (perform-system-action name #'list-current-system-files))
  101.  
  102. (defun count-system-lines (name)
  103.   (perform-system-action name #'count-system-lines-internal))
  104.  
  105. (defun count-system-characters (name)
  106.   (perform-system-action name #'count-system-characters-internal))
  107.  
  108. (defun edit-system (name)
  109.   (perform-system-action name #'edit-system-internal))
  110.  
  111. (defun print-system (name)
  112.   (perform-system-action name #'print-system-internal))
  113.  
  114. (defun build-system-internal ()
  115.   (let ((*load-verbose* nil)
  116.     (component (system-info-files *info*)))
  117.     (build-component component :if-needed)))
  118.  
  119. (defun build-components (components condition)
  120.   (dolist (component components)
  121.     (build-component component condition)))
  122.  
  123. (defun build-component (component condition)
  124.   (if (atom component)
  125.       (update-and-load-file component condition)
  126.       (funcall (case (first component)
  127.          (:sequential #'sequential-build)
  128.          (:parallel #'parallel-build)
  129.          (:interpreted-only #'interpreted-build)
  130.          (t #'sequential-build))
  131.            (cdr component)
  132.            condition)))
  133.  
  134. ;;; Build-the sub-components sequentially, updating branch-need; however,
  135. ;;; as soon as sub-component N requires updating, then all subsequent
  136. ;;; sub-components MUST be rebuilt.
  137. (defun sequential-build (components condition)
  138.   (labels ((iter (components must-update?)
  139.          (if (null components)
  140.          must-update?
  141.          (iter (cdr components)
  142.                (build-component (car components)
  143.                     (if must-update?
  144.                         :always
  145.                         :if-needed))))))
  146.     (iter components (if (eq condition :always)
  147.              t
  148.              nil))))
  149.  
  150. (defun parallel-build (components condition)
  151.   (do ((rest (cdr components) (cdr rest))
  152.        (component (car components) (car rest))
  153.        (any-updates? nil (let ((update? (build-component component
  154.                              condition)))
  155.                (or update? any-updates?))))
  156.       ((null component) any-updates?)))
  157.  
  158. (defun interpreted-build (component)
  159.   (declare (ignore component))
  160.   (error "Not written yet"))
  161.  
  162. ;;; Return T if the component needs updating, else NIL.
  163. (defun update-and-load-file (file condition)
  164.   (prog1 (update-file file condition)
  165.     (unless *skip-load?*
  166.       (load-file (make-full-pathname file :binary) condition))))
  167.  
  168. (defun update-file (file condition)
  169.   (if (eq condition :always)
  170.       (do-compile-file file "~%:SEQUENTIAL update ~S")
  171.       (if (file-update-needed-p file)
  172.       (do-compile-file file "~%~S needs updating.")
  173.       nil)))
  174.  
  175. ;;; Always return true to indicate that we updated the file.
  176. (defun do-compile-file (file format-string)
  177.   (let ((source-name (make-full-pathname file :source)))
  178.     (format t format-string source-name source-name)
  179.     (force-output t)
  180.     (funcall *system-builder-compiler* source-name)
  181.     t))
  182.  
  183. (defun file-update-needed-p (file)
  184.   (or *force-update?*
  185.       (let ((source-name (make-full-pathname file :source))
  186.         (binary-name (make-full-pathname file :binary)))
  187.     (or (null (probe-file binary-name))
  188.         (> (file-write-date source-name)
  189.            (file-write-date binary-name))))))
  190.  
  191. (defun load-file (pathname condition)
  192.   (let* ((current-load-date-table (system-info-load-date-table *info*))
  193.      (last-load-write-date (gethash pathname current-load-date-table))
  194.      (bin-pathname (make-full-pathname pathname :binary))
  195.      (current-write-date (if (probe-file bin-pathname)
  196.                  (file-write-date bin-pathname)
  197.                  nil))
  198.      (reload-needed? (or (null last-load-write-date)
  199.                  (null current-write-date)
  200.                  (not (= last-load-write-date
  201.                      current-write-date)))))
  202.     (if (or (eq condition :always)
  203.         reload-needed?)
  204.     (progn (if (and (eq condition :always)
  205.             (not reload-needed?))
  206.            (format t
  207.                "~%:always reload of ~S..."
  208.                pathname)
  209.            (format t "~&Loading ~S... " pathname))
  210.            (force-output *terminal-io*)
  211.            (load bin-pathname)
  212.            (setf (gethash pathname current-load-date-table)
  213.              current-write-date)
  214.            (format t "done.~%"))
  215.     (when *verbose-build*
  216.       (format t "~%~S has not changed since last load" pathname)))))
  217.  
  218. (defun make-full-pathname (file type)
  219.   (merge-pathnames
  220.    file
  221.    (make-pathname :host (pathname-host
  222.              (system-info-directory *info*))
  223.           #+cmu :device #+cmu :absolute
  224.           :directory (pathname-directory (system-info-directory
  225.                           *info*))
  226.           :type (ecase type
  227.               (:source (system-info-source-extension
  228.                     *info*))
  229.               (:binary (system-info-binary-extension
  230.                     *info*))))))
  231.  
  232.  
  233. ;;; Useful stuff for counting source code lines.
  234. (defun count-system-lines-internal ()
  235.   (let ((files (list-current-system-files)))
  236.     (do ((file-list (cdr files) (cdr file-list))
  237.      (file (car files) (car file-list))
  238.      (sum 0 (progn
  239.          (format t "~%Counting lines in ~A..." file)
  240.          (let ((num-lines (count-file-lines
  241.                    (make-full-pathname file :source))))
  242.            (format t " read ~A lines." num-lines)
  243.            (+ sum num-lines)))))
  244.     ((null file) (format t
  245.                  "~%Total of ~A lines in system ~A"
  246.                  sum
  247.                  (system-info-name *info*))
  248.                  sum))))
  249.  
  250. (defun count-system-characters-internal ()
  251.   (let ((files (list-current-system-files)))
  252.     (do ((file-list (cdr files) (cdr file-list))
  253.      (file (car files) (car file-list))
  254.      (sum 0 (progn
  255.          (format t "~%Counting characters in ~A..." file)
  256.          (let ((num-chars (count-file-characters
  257.                    (make-full-pathname file :source))))
  258.            (format t " read ~A characters" num-chars)
  259.            (+ sum num-chars)))))
  260.     ((null file) (format t
  261.                  "~%Total of ~A characters in system ~A"
  262.                  sum
  263.                  (system-info-name *info*))
  264.                  sum))))
  265.  
  266. ;;; This is ugly and should be rewritten
  267. (defun list-current-system-files ()
  268.   (labels ((list-em (rest so-far)
  269.          (if (null rest)
  270.          (nreverse so-far)
  271.          (list-em (cdr rest)
  272.               (if (listp (car rest))
  273.                   (append (nreverse (list-em (car rest) nil))
  274.                       so-far)
  275.                   (if (member (car rest)
  276.                       '(:serial :parallel))
  277.                   so-far
  278.                   (cons (car rest) so-far)))))))
  279.     (let ((files (list-em (system-info-files *info*) nil)))
  280.       (loop for f in files collect (make-full-pathname f :source)))))
  281.  
  282. (defun count-file-lines (pathname)
  283.   (with-open-file (file-stream pathname)
  284.     (do ((count 0 (1+ count))
  285.      (line (read-line file-stream nil file-stream)
  286.            (read-line file-stream nil file-stream)))
  287.     ((eq line file-stream) count))))
  288.  
  289. (defun count-file-characters (pathname)
  290.   (with-open-file (file-stream pathname)
  291.     (do ((count 0 (1+ count))
  292.      (char (read-char file-stream nil file-stream)
  293.            (read-char file-stream nil file-stream)))
  294.     ((eq char file-stream) count))))
  295.  
  296.